home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
pcl
/
pcl-rev4.lha
/
cpl.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1990-01-25
|
11KB
|
311 lines
;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
;;;
;;; compute-class-precedence-list
;;;
;;; Knuth section 2.2.3 has some interesting notes on this.
;;;
;;; What appears here is basically the algorithm presented there.
;;;
;;; The key idea is that we use class-precedence-description (CPD) structures
;;; to store the precedence information as we proceed. The CPD structure for
;;; a class stores two critical pieces of information:
;;;
;;; - a count of the number of "reasons" why the class can't go
;;; into the class precedence list yet.
;;;
;;; - a list of the "reasons" this class prevents others from
;;; going in until after it
;;
;;; A "reason" is essentially a single local precedence constraint. If a
;;; constraint between two classes arises more than once it generates more
;;; than one reason. This makes things simpler, linear, and isn't a problem
;;; as long as we make sure to keep track of each instance of a "reason".
;;;
;;; This code is divided into three phases.
;;;
;;; - the first phase simply generates the CPD's for each of the class
;;; and its superclasses. The remainder of the code will manipulate
;;; these CPDs rather than the class objects themselves. At the end
;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
;;; of the direct superclasses of the class.
;;;
;;; - the second phase folds all the local constraints into the CPD
;;; structure. The CPD-COUNT of each CPD is built up, and the
;;; CPD-AFTER fields are augmented to include precedence constraints
;;; from the CPD-SUPERS field and from the order of classes in other
;;; CPD-SUPERS fields.
;;;
;;; After this phase, the CPD-AFTER field of a class includes all the
;;; direct superclasses of the class plus any class that immediately
;;; follows the class in the direct superclasses of another. There
;;; can be duplicates in this list. The CPD-COUNT field is equal to
;;; the number of times this class appears in the CPD-AFTER field of
;;; all the other CPDs.
;;;
;;; - In the third phase, classes are put into the precedence list one
;;; at a time, with only those classes with a CPD-COUNT of 0 being
;;; candidates for insertion. When a class is inserted , every CPD
;;; in its CPD-AFTER field has its count decremented.
;;;
;;; In the usual case, there is only one candidate for insertion at
;;; any point. If there is more than one, the specified tiebreaker
;;; rule is used to choose among them.
;;;
(defmethod compute-class-precedence-list ((root std-class) direct-superclasses)
(compute-std-cpl root direct-superclasses))
(defstruct (class-precedence-description
(:conc-name nil)
(:print-function (lambda (obj str depth)
(declare (ignore depth))
(format str
"#<CPD ~S ~D>"
(class-name (cpd-class obj))
(cpd-count obj))))
(:constructor make-cpd ()))
(cpd-class nil)
(cpd-supers ())
(cpd-after ())
(cpd-count 0))
(defun compute-std-cpl (class supers)
(cond ((null supers) ;First two branches of COND
(list class)) ;are implementing the single
((null (cdr supers)) ;inheritance optimization.
(cons class
(compute-std-cpl (car supers)
(class-direct-superclasses (car supers)))))
(t
(multiple-value-bind (all-cpds nclasses)
(compute-std-cpl-phase-1 class supers)
(compute-std-cpl-phase-2 all-cpds)
(compute-std-cpl-phase-3 class all-cpds nclasses)))))
(defvar *compute-std-cpl-class->entry-table-size* 60)
(defun compute-std-cpl-phase-1 (class supers)
(let ((nclasses 0)
(all-cpds ())
(table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
:test #'eq)))
(labels ((get-cpd (c)
(or (gethash c table)
(setf (gethash c table) (make-cpd))))
(walk (c supers)
(if (forward-referenced-class-p c)
(cpl-forward-referenced-class-error class c)
(let ((cpd (get-cpd c)))
(unless (cpd-class cpd) ;If we have already done this
;class before, we can quit.
(setf (cpd-class cpd) c)
(incf nclasses)
(push cpd all-cpds)
(setf (cpd-supers cpd) (mapcar #'get-cpd supers))
(dolist (super supers)
(walk super (class-direct-superclasses super))))))))
(walk class supers)
(values all-cpds nclasses))))
(defun compute-std-cpl-phase-2 (all-cpds)
(dolist (cpd all-cpds)
(let ((supers (cpd-supers cpd)))
(when supers
(setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
(incf (cpd-count (car supers)) 1)
(do* ((t1 supers t2)
(t2 (cdr t1) (cdr t1)))
((null t2))
(incf (cpd-count (car t2)) 2)
(push (car t2) (cpd-after (car t1))))))))
(defun compute-std-cpl-phase-3 (class all-cpds nclasses)
(let ((candidates ())
(next-cpd nil)
(rcpl ()))
;;
;; We have to bootstrap the collection of those CPD's that
;; have a zero count. Once we get going, we will maintain
;; this list incrementally.
;;
(dolist (cpd all-cpds)
(when (zerop (cpd-count cpd)) (push cpd candidates)))
(loop
(when (null candidates)
;;
;; If there are no candidates, and enough classes have been put
;; into the precedence list, then we are all done. Otherwise
;; it means there is a consistency problem.
(if (zerop nclasses)
(return (reverse rcpl))
(cpl-inconsistent-error class all-cpds)))
;;
;; Try to find the next class to put in from among the candidates.
;; If there is only one, its easy, otherwise we have to use the
;; famous RPG tiebreaker rule. There is some hair here to avoid
;; having to call DELETE on the list of candidates. I dunno if
;; its worth it but what the hell.
;;
(setq next-cpd
(if (null (cdr candidates))
(prog1 (car candidates)
(setq candidates ()))
(block tie-breaker
(dolist (c rcpl)
(let ((supers (class-direct-superclasses c)))
(if (memq (cpd-class (car candidates)) supers)
(return-from tie-breaker (pop candidates))
(do ((loc candidates (cdr loc)))
((null (cdr loc)))
(let ((cpd (cadr loc)))
(when (memq (cpd-class cpd) supers)
(setf (cdr loc) (cddr loc))
(return-from tie-breaker cpd))))))))))
(decf nclasses)
(push (cpd-class next-cpd) rcpl)
(dolist (after (cpd-after next-cpd))
(when (zerop (decf (cpd-count after)))
(push after candidates))))))
;;;
;;; Support code for signalling nice error messages.
;;;
(defun cpl-error (class format-string &rest format-args)
(error "While computing the class precedence list of the class ~A.~%~A"
(if (class-name class)
(format nil "named ~S" (class-name class))
class)
(apply #'format nil format-string format-args)))
(defun cpl-forward-referenced-class-error (class forward-class)
(flet ((class-or-name (class)
(if (class-name class)
(format nil "named ~S" (class-name class))
class)))
(let ((names (mapcar #'class-or-name
(cdr (find-superclass-chain class forward-class)))))
(cpl-error class
"The class ~A is a forward referenced class.~@
The class ~A is ~A."
(class-or-name forward-class)
(class-or-name forward-class)
(if (null (cdr names))
(format nil
"a direct superclass of the class ~A"
(class-or-name class))
(format nil
"reached from the class ~A by following~@
the direct superclass chain through: ~A~
~% ending at the class ~A"
(class-or-name class)
(format nil
"~{~% the class ~A,~}"
(butlast names))
(car (last names))))))))
(defun find-superclass-chain (bottom top)
(labels ((walk (c chain)
(if (eq c top)
(return-from find-superclass-chain (nreverse chain))
(dolist (super (class-direct-superclasses c))
(walk super (cons super chain))))))
(walk bottom (list bottom))))
(defun cpl-inconsistent-error (class all-cpds)
(let ((reasons (find-cycle-reasons all-cpds)))
(cpl-error class
"It is not possible to compute the class precedence list because~@
there ~A in the local precedence relations.~@
~A because:~{~% ~A~}."
(if (cdr reasons) "are circularities" "is a circularity")
(if (cdr reasons) "These arise" "This arises")
(format-cycle-reasons (apply #'append reasons)))))
(defun format-cycle-reasons (reasons)
(flet ((class-or-name (cpd)
(let ((class (cpd-class cpd)))
(if (class-name class)
(format nil "named ~S" (class-name class))
class))))
(mapcar
#'(lambda (reason)
(ecase (caddr reason)
(:super
(format
nil
"the class ~A appears in the supers of the class ~A"
(class-or-name (cadr reason))
(class-or-name (car reason))))
(:in-supers
(format
nil
"the class ~A follows the class ~A in the supers of the class ~A"
(class-or-name (cadr reason))
(class-or-name (car reason))
(class-or-name (cadddr reason))))))
reasons)))
(defun find-cycle-reasons (all-cpds)
(let ((been-here ()) ;List of classes we have visited.
(cycle-reasons ()))
(labels ((chase (path)
(if (memq (car path) (cdr path))
(record-cycle (memq (car path) (nreverse path)))
(unless (memq (car path) been-here)
(push (car path) been-here)
(dolist (after (cpd-after (car path)))
(chase (cons after path))))))
(record-cycle (cycle)
(let ((reasons ()))
(do* ((t1 cycle t2)
(t2 (cdr t1) (cdr t1)))
((null t2))
(let ((c1 (car t1))
(c2 (car t2)))
(if (memq c2 (cpd-supers c1))
(push (list c1 c2 :super) reasons)
(dolist (cpd all-cpds)
(when (memq c2 (memq c1 (cpd-supers cpd)))
(return
(push (list c1 c2 :in-supers cpd) reasons)))))))
(push (nreverse reasons) cycle-reasons))))
(dolist (cpd all-cpds)
(unless (zerop (cpd-count cpd))
(chase (list cpd))))
cycle-reasons)))